home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chip 2004 April
/
CMCD0404.ISO
/
Software
/
Shareware
/
Programare
/
sharp
/
wwwSharp_setup.exe
/
{app}
/
Examples
/
RssPublisher
/
Source
/
RssPublisher.vbs
< prev
next >
Wrap
Text File
|
2004-02-04
|
19KB
|
668 lines
Option Explicit
Dim BookmarkType
Dim rsArticles
Dim CurrentBookmark
BookmarkType = vbEmpty
rsArticles = Null
CurrentBookmark = Null
Function VarAsType(Value, ValueType)
Select Case ValueType
Case vbInteger VarAsType = CInt(Value)
Case vbLong VarAsType = CLng(Value)
Case vbSingle VarAsType = CSng(Value)
Case vbDouble VarAsType = CDbl(Value)
Case vbCurrency VarAsType = CCur(Value)
Case vbDate VarAsType = CDate(Value)
Case vbString VarAsType = CStr(Value)
Case vbBoolean VarAsType = CBool(Value)
Case vbVariant VarAsType = Value 'Leave as is
Case vbByte VarAsType = CByte(Value)
Case Else Err.Raise 5, "Convertion", "Convertion failed"
End Select
End Function
Sub CleanupArticle()
document.all.inpArticleTitle.innerText = ""
document.all.inpArticleDescription.innerText = ""
document.all.inpArticleURL.innerText = ""
document.all.inpArticleDate.innerText = ""
document.all.inpArticleCategory.innerText = ""
document.all.inpArticleKeywords.innerText = ""
document.all.inpArticleAuthorNames.innerText = ""
document.all.inpArticleAuthorEmails.innerText = ""
End Sub
Sub CleanupArticles()
CleanupArticle()
document.all.tblArticleList.outerHTML = "<TABLE id=""tblArticleList"" cols=""1"" border=""0""></TABLE>"
End Sub
Sub CleanupSite()
document.all.inpSiteTitle.innerText = ""
document.all.inpSiteDescription.innerText = ""
document.all.inpSiteURL.innerText = ""
document.all.inpSiteDetails.innerText = ""
document.all.inpSiteImageURL.innerText = ""
document.all.inpSiteFurtherReading.innerText = ""
document.all.inpSiteAuthorNames.innerText = ""
document.all.inpSiteAuthorEmails.innerText = ""
End Sub
Sub CleanupAll()
CleanupSite()
CleanupArticles()
End Sub
Sub SetInputText(RootNode, inputControl, NodePath)
Dim Node
Set Node = RootNode.selectSingleNode(NodePath)
If IsEmpty(Node) or IsNull(Node) or (Node is Nothing) Then Exit Sub
inputControl.innerText = Node.text
End Sub
' Retrieve authors name and email from dc:creator node
Sub FindAuthors(RootNode, ByRef Authors, ByRef Emails)
Dim Nodes, Node, i, AuthorText, Pos, Author, Email
Authors = ""
Emails = ""
Set Nodes = RootNode.selectNodes("./dc:creator")
For i = 0 To Nodes.length-1
Set Node = Nodes.item(i)
AuthorText = Node.text
Pos = InStr(1, AuthorText, "(mailto:", 1)
If Pos > 0 Then
Author = Trim(Mid(AuthorText, 1, Pos-1))
Email = Trim(Mid(AuthorText, Pos + Len("(mailto:")))
If (Len(Email) > 0) and (Mid(Email, Len(Email), 1) = ")") Then
Email = Mid(Email, 1, Len(Email) - 1)
End If
Else
Author = AuthorText
Email = ""
End If
If Len(Authors) > 0 Then Authors = Authors & "|"
Authors = Authors & Author
if Len(Emails) > 0 Then Emails = Emails & "|"
Emails = Emails & Email
Next
End Sub
Sub SetAuthors(RootNode)
Dim Authors, Emails
FindAuthors RootNode, Authors, Emails
document.all.inpSiteAuthorNames.innerText = Authors
document.all.inpSiteAuthorEmails.innerText = Emails
End Sub
Sub OpenChannel(Channel)
SetInputText Channel, document.all.inpSiteTitle, "./title"
SetInputText Channel, document.all.inpSiteDescription, "./description"
SetInputText Channel, document.all.inpSiteURL, "./link"
SetInputText Channel, document.all.inpSiteDetails, "./dc:publisher"
SetInputText Channel, document.all.inpSiteImageURL, "./image/@rdf:resource"
SetInputText Channel, document.all.inpSiteFurtherReading, "./fr:url"
SetAuthors Channel
End Sub
' Create new recordset
Sub CreateRecordset()
Dim rs
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
MsgBox("Create: " & Err.Description)
Exit Sub
End If
rs.Fields.Append "Title", 200, 255, &H64 'adVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull
rs.Fields.Append "Description", 201, 4000, &HE4 'adLongVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull or adFldLong
rs.Fields.Append "URL", 200, 255, &H64
rs.Fields.Append "Date", 200, 80, &H64
rs.Fields.Append "Category", 200, 50, &H64
rs.Fields.Append "Keywords", 200, 255, &H64
rs.Fields.Append "Author", 200, 255, &H64
rs.Fields.Append "Email", 200, 255, &H64
If Err.Number <> 0 Then
MsgBox("Add fields: " & Err.Description)
Exit Sub
End If
rs.Open
If Err.Number <> 0 Then
MsgBox("Open: " & Err.Description)
Exit Sub
End If
Set rsArticles = rs
End Sub
Sub SetColumnValue(RootNode, ColumnName, NodePath)
On Error Resume Next
Dim Node
Set Node = RootNode.selectSingleNode(NodePath)
If IsEmpty(Node) or IsNull(Node) or (Node Is Nothing) Then Exit Sub
rsArticles(ColumnName) = CStr(Node.text)
End Sub
Sub OpenItem(Item)
On Error Resume Next
Dim Authors, Emails
Authors = ""
Emails = ""
rsArticles.AddNew()
SetColumnValue Item, "Title", "./title"
SetColumnValue Item, "Description", "./description"
SetColumnValue Item, "URL", "./link"
SetColumnValue Item, "Date", "./dc:date"
SetColumnValue Item, "Category", "./pa:category"
SetColumnValue Item, "Keywords", "./pa:keywords"
FindAuthors Item, Authors, Emails
rsArticles("Author") = Authors
rsArticles("Email") = Emails
rsArticles.Update()
End Sub
Sub OnBtnOpenRSSClick()
CleanupAll()
rsArticles = Null
Dim xmlDoc, Channel, Items, Item, Node, i
Set xmlDoc = CreateObject("MsXml2.DOMDocument")
cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
cDialog.FileName = ""
cDialog.CancelError = True
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
xmlDoc.async = False
xmlDoc.validateOnParse = True
xmlDoc.Load(cDialog.FileName)
If xmlDoc.parseError.ErrorCode <> 0 Then
Err.Raise 5, "RSS Reader", xmlDoc.parseError.reason
End If
'Process only first channel, ignore others if any
Set Channel = xmlDoc.documentElement.selectSingleNode("./channel")
If IsEmpty(Channel) or IsNull(Channel) or (Channel is Nothing) Then
Err.Raise 5, "RSS Reader", "RSS File is invalid"
End If
OpenChannel(Channel)
CreateRecordset()
Set Items = xmlDoc.documentElement.selectNodes("./item")
For i = 0 to (Items.length - 1)
Set Item = Items.item(i)
OpenItem(Item)
Next
FillArticleList()
End Sub
Sub OnBtnImportADOClick()
Dim locator, conn
Set locator = CreateObject("DataLinks")
Set conn = locator.PromptNew()
If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
conn.Open()
On Error Resume Next
Dim strTableName
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Sub OnBtnImportAccessClick()
cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Sub OnBtnImportExcelClick()
cDialog.Filter = "MS Excel files (*.xls)|*.xls"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
";Extended properties=Excel 8.0;")
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Function PersistRSS()
PersistRSS = False
Dim res
res = RssHeader(document.all.inpSiteTitle.value, _
document.all.inpSiteDescription.value, _
document.all.inpSiteURL.value, _
document.all.inpSiteDetails.value, _
document.all.inpSiteImageURL.value, _
document.all.inpSiteFurtherReading.value, _
document.all.inpSiteAuthorNames.value, _
document.all.inpSiteAuthorEmails.value)
If Not res Then
MsgBox("Site information is not complete.")
Exit Function
End If
If Not IsNull(rsArticles) and Not (rsArticles.BOF and rsArticles.EOF) Then
rsArticles.MoveFirst()
While Not rsArticles.EOF
res = RssItem(rsArticles("Title"), rsArticles("Description"), rsArticles("URL"), _
rsArticles("Date"), rsArticles("Category"), rsArticles("Keywords"), _
rsArticles("Author"), rsArticles("Email"))
If Not res Then
MsgBox("Error writing article: " + rs("Title"))
Exit Function
End If
rsArticles.MoveNext()
Wend
End If
res = RssFooter()
If Not res Then
MsgBox("Can not write footer")
Exit Function
End If
PersistRSS = True
End Function
Sub OnBtnSaveRSSClick()
If Not PersistRSS Then Exit Sub
cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
cDialog.FileName = ""
cDialog.CancelError = True
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
Dim res
res = RssPersist(cDialog.FileName)
sRSSXML = ""
If Not res Then
MsgBox("Can not save file")
Exit Sub
End If
End Sub
Sub OnBtnExportADOClick()
Dim locator, conn
Set locator = CreateObject("DataLinks")
Set conn = locator.PromptNew()
If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
conn.Open()
On Error Resume Next
Dim strTableName
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnBtnExportAccessClick()
cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(dbFileName) Then
Dim cat
Set cat = CreateObject("ADOX.Catalog")
cat.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
Set cat = Nothing
End If
Set fso = Nothing
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
On Error Resume Next
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnBtnExportToExcelClick()
cDialog.Filter = "MS Excel files (*.xls)|*.xls"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName, conn
dbFileName = cDialog.FileName
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
";Extended properties=Excel 8.0;")
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
On Error Resume Next
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnTblArticleListClick()
Dim srcElement
Set srcElement = window.event.srcElement
If srcElement.tagName <> "A" or IsNull(rsArticles) Then Exit Sub
CleanupArticle()
Dim strBookmark
strBookmark = CStr(srcElement.id)
If Len(strBookmark) > 3 Then
strBookmark = Mid(strBookmark, 4)
Else
Exit Sub
End If
CurrentBookmark = VarAsType(strBookmark, BookmarkType)
rsArticles.Bookmark = CurrentBookmark
On Error Resume Next
document.all.inpArticleTitle.value = CStr(rsArticles("Title"))
document.all.inpArticleDescription.value = CStr(rsArticles("Description"))
document.all.inpArticleURL.value = CStr(rsArticles("Url"))
document.all.inpArticleDate.value = CStr(rsArticles("Date"))
document.all.inpArticleCategory.value = CStr(rsArticles("Category"))
document.all.inpArticleKeywords.value = CStr(rsArticles("Keywords"))
document.all.inpArticleAuthorNames.value = CStr(rsArticles("Author"))
document.all.inpArticleAuthorEmails.value = CStr(rsArticles("Email"))
End Sub
Function PromptTableName(conn)
'PromptTableName = window.prompt("Table name:", "Articles")
PromptTableName = CStr(window.showModalDialog("ChooseTable.html", conn, _
"dialogHeight: 350px; dialogWidth: 400px; center: yes; help: no; resizable: no; status: no"))
If PromptTableName = "" Then Err.Raise 5
End Function
Sub FillArticleList()
Dim strArticles
strArticles = "<TABLE id=""tblArticleList"" border=""0"" width=""100%"" onclick=""OnTblArticleListClick()"">" & vbCRLF
On Error Resume Next
rsArticles.MoveFirst()
If Err.Number <> 0 Then Exit Sub
BookmarkType = VarType(rsArticles.Bookmark)
While Not rsArticles.EOF
Dim strRow
strRow = "<TR>" & vbCRLF
'Bookmark is stored in ID attribute as "artXXX"
strRow = strRow & "<TD><A href=""#"" id=""art" & CStr(rsArticles.Bookmark) & """>" & _
rsArticles("Title") & "</A></TD>" & vbCRLF
strRow = strRow & "</TR>" & vbCRLF
strArticles = strArticles & strRow
rsArticles.MoveNext()
Wend
strArticles = strArticles & "</TABLE>" & vbCRLF
document.all.tblArticleList.outerHTML = strArticles
End Sub
Sub DoImport(conn, tblName)
On Error Resume Next
CleanupArticles()
rsArticles = Null
Dim rs
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = 3 'adUseClient
rs.LockType = 4 'adLockBatchOptimistic
If Mid(UCase(tblName), 1, 7) <> "SELECT " Then
tblName = "SELECT [Title], [Description], [URL], [Date], [Category], [Keywords], " & _
"[Author], [Email] FROM [" & tblName & "] ORDER BY [Title]"
End If
rs.Open tblName, conn
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
'Disconnect recordset
Set rs.ActiveConnection = Nothing
Set rsArticles = rs
FillArticleList()
End Sub
Sub DoExport(conn, tblName)
On Error Resume Next
Dim strCreateTable
strCreateTable = "CREATE TABLE [" & tblName & "] ([ID] AutoIncrement, [Title] VarChar(255), " & _
"[Description] Memo, [URL] VarChar(255), [Date] VarChar(80), [Category] VarChar(50), " & _
"[Keywords] VarChar(255), [Author] VarChar(255), [Email] VarChar(255))"
conn.Execute(strCreateTable)
If Err.Number <> 0 Then
MsgBox "Can not create table: " & tblName
Exit Sub
End If
Dim rs
Set rs = CreateObject("ADODB.Recordset")
rs.Open "SELECT * FROM [" & tblName & "]", conn, 0, 3 'adOpenForwardOnly, adLockOptimistic
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
Dim i
i = 0
rsArticles.MoveFirst()
While Not rsArticles.EOF
rs.AddNew()
rs("Title") = rsArticles("Title")
rs("Description") = rsArticles("Description")
rs("URL") = rsArticles("URL")
rs("Date") = rsArticles("Date")
rs("Category") = rsArticles("Category")
rs("Keywords") = rsArticles("Keywords")
rs("Author") = rsArticles("Author")
rs("Email") = rsArticles("Email")
rs.Update()
rsArticles.MoveNext()
i = i + 1
Wend
MsgBox("Imported " & CStr(i) & " articles.")
End Sub
Function FindCurrentRow()
FindCurrentRow = Null
If IsNull(rsArticles) or IsNull(CurrentBookmark) Then Exit Function
Dim tblArticles
Set tblArticles = document.all.tblArticleList
If IsEmpty(tblArticles) or IsNull(tblArticles) or (tblArticles is Nothing) Then Exit Function
rsArticles.Bookmark = CurrentBookmark
Set FindCurrentRow = tblArticles.all.item("art" & CStr(CurrentBookmark))
Do
If IsEmpty(FindCurrentRow) or IsNull(FindCurrentRow) or (FindCurrentRow is Nothing) or _
(FindCurrentRow.tagName = "TR") Then Exit Do
Set FindCurrentRow = FindCurrentRow.parentElement
Loop
If IsEmpty(FindCurrentRow) or (FindCurrentRow is Nothing) Then FindCurrentRow = Null
End Function
Sub OnBtnAddArticleClick()
On Error Resume Next
CleanupArticle()
If IsEmpty(rsArticles) or IsNull(rsArticles) Then
CreateRecordset()
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
End If
rsArticles.AddNew()
rsArticles("Title") = "<New article>"
rsArticles("Date") = Now
rsArticles.Update()
If Err.Number <> 0 Then
Err.Description
Exit Sub
End If
CurrentBookmark = rsArticles.Bookmark
If BookmarkType = vbEmpty Then BookmarkType = VarType(CurrentBookmark)
Dim tblArticles, row, cell, link, strLink
Set tblArticles = document.all.tblArticleList
Set row = tblArticles.insertRow()
Set cell = row.insertCell()
Set link = document.createElement("<A href=""#"" id=""art" & CStr(rsArticles.Bookmark) & """>")
cell.appendChild(link)
link.innerText = rsArticles("Title")
link.click()
End Sub
Sub OnBtnRemoveArticleClick()
Dim CurrentRow
Set CurrentRow = FindCurrentRow
If IsNull(CurrentRow) Then Exit Sub
On Error Resume Next
CleanupArticle()
rsArticles.Delete 1 'adAffectCurrent
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
Dim tblArticles
Set tblArticles = document.all.tblArticleList
tblArticles.deleteRow CurrentRow.rowIndex
End Sub
Function GetValueAsStringOrNull(Value)
GetValueAsStringOrNull = CStr(Value)
If Len(Value) = 0 Then GetValueAsStringOrNull = Null
End Function
Sub OnBtnUpdateArticleClick()
Dim CurrentRow
Set CurrentRow = FindCurrentRow
If IsNull(CurrentRow) Then Exit Sub
On Error Resume Next
rsArticles("Title").Value = GetValueAsStringOrNull(document.all.inpArticleTitle.value)
rsArticles("Description").Value = GetValueAsStringOrNull(document.all.inpArticleDescription.value)
rsArticles("Url").Value = GetValueAsStringOrNull(document.all.inpArticleURL.value)
rsArticles("Date").Value = GetValueAsStringOrNull(document.all.inpArticleDate.value)
rsArticles("Category").Value = GetValueAsStringOrNull(document.all.inpArticleCategory.value)
rsArticles("Keywords").Value = GetValueAsStringOrNull(document.all.inpArticleKeywords.value)
rsArticles("Author").Value = GetValueAsStringOrNull(document.all.inpArticleAuthorNames.value)
rsArticles("Email").Value = GetValueAsStringOrNull(document.all.inpArticleAuthorEmails.value)
rsArticles.Update()
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
document.all.tblArticleList.all.item("art" & CStr(CurrentBookmark)).innerText = rsArticles("Title")
End Sub
'Pass data as Class is required becaus window.dialogArguments does not
'accept strings longer than 4096 characters
Class RssData
Public Property Get RssXml
RssXml = sRSSXML
End Property
End Class
Sub OnBtnPreviewClick()
If Not PersistRSS Then Exit Sub
window.showModalDialog "Preview.html", new RssData, _
"dialogHeight: 500px; dialogWidth: 750px; center: yes; help: no; resizable: yes; status: no"
sRSSXML = ""
End Sub